home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / amsf20.zip / AMSF.FOR < prev    next >
Text File  |  1992-01-06  |  46KB  |  1,451 lines
  1. C     ******************************************************************
  2. C     *                                                                *
  3. C     *                            A M S F                             *
  4. C     *                                                                *
  5. C     *        ARRAY MANAGEMENT SYSTEM  /  FORTRAN VERSION 2.0         *
  6. C     *                                                                *
  7. C     *                                                                *
  8. C     *               (C) 1987, 1988, 1989 BY T.-S. YANG               *
  9. C     *                                                                *
  10. C     *         AERONAUTICAL RESEARCH LABORATORY, AIDC, CSIST.         *
  11. C     *         90008-11-3 TAICHUNG, TAIWAN, REPUBLIC OF CHINA         *
  12. C     *                                                                *
  13. C     ******************************************************************
  14.       BLOCK DATA
  15.       IMPLICIT INTEGER*4(I-N)
  16.       INCLUDE 'AMSCTL.INC'
  17.       DATA NVERSN/2/, LIMIT/55/
  18.       DATA NDATA,LENG,INTL,LENDIR/5,128,4,16/
  19.       DATA NDT/1,2,4/,ISORT/0/,NXTLOC/1/,MCK/0/
  20.       DATA NARY,NOPEN,NREC,NOFF/5*0,5*0,5*2,5*1/
  21.       DATA NTM,NTR/0,0/
  22.       DATA NDB,NTF/11,12,13,14,15,16/
  23.       END
  24.  
  25.       SUBROUTINE CLOCK( KTM )
  26.       IMPLICIT INTEGER*4(I-N)
  27. C ... LEVEL 0 : READ DATE/TIME VALUES FROM CLOCK AND STORE IT IN KTM
  28. C     (THIS SUBROUTINE IS FOR MICROSOFT FORTRAN 4.0)
  29.       DIMENSION KTM(6)
  30.       INTEGER*2 IT(7)
  31. C ... KTM(I),I=1,6: YEAR, MONTH, DAY, HOUR, MINUTE, SECOND
  32.       CALL GETDAT(IT(1),IT(2),IT(3))
  33.       CALL GETTIM(IT(4),IT(5),IT(6),IT(7))
  34.       DO 10 I=1,6
  35. 10    KTM(I) = IT(I)
  36.       RETURN
  37.       END
  38. C
  39.       SUBROUTINE DATES (KTM,DST)
  40.       IMPLICIT INTEGER*4(I-N)
  41. C ... LEVEL 0: CONVERT DATE/TIME FROM INTEGER TO STRING
  42.       DIMENSION KTM(6),NC(12)
  43.       CHARACTER DST*(*),APM*3,DT(12)*10
  44.       DATA DT/'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY',
  45.      *        'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'/
  46.       DATA NC/8,9,6,6,4,5,5,7,10,8,9,9/
  47.       KT4 = KTM(4)
  48.       APM = ' AM'
  49.       IF (KTM(4).GE.12) APM = ' PM'
  50.       IF (KTM(4).GT.12) KT4 = KT4 - 12
  51.       IM = KTM(2)
  52.       WRITE(DST,10) KT4,KTM(5),KTM(6),APM,DT(IM)(1:NC(IM)),KTM(3),KTM(1)
  53. 10    FORMAT(I2.2,':',I2.2,':',I2.2,A,', ',A,I2,', ',I4)
  54.       RETURN
  55.       END
  56. C
  57.       SUBROUTINE INIT
  58.       IMPLICIT INTEGER*4(I-N)
  59. C ... LEVEL 0: INITIALIZE ARRAY MANEGEMENT SYSTEM
  60.       COMMON MAVAIL,IA(30000)
  61.       INCLUDE 'AMSCTL.INC'
  62.       IF (MAVAIL.LT.30000) MAVAIL = 30000
  63.       IDIR   = MAVAIL + 1
  64.       RETURN
  65.       END
  66. C
  67.       SUBROUTINE ERROR(ND,NAME,NV,NCODE)
  68.       IMPLICIT INTEGER*4(I-N)
  69. C ... LEVEL 0: PRINT ERROR MESSAGES
  70.       CHARACTER NAME*(*),ERRMSG(21)*50
  71.       COMMON MAVAIL,IA(1)
  72.       INCLUDE 'AMSCTL.INC'
  73.       DATA NERROR/21/
  74.       DATA ERRMSG/'ILLEGAL MATRIX DATA TYPE',
  75.      *            'ILLEGAL MATRIX STORAGE MODE',
  76.      *            'NON-POSITIVE ROW DIMENSION',
  77.      *            'NON-POSITIVE COLUMN DIMENSION',
  78.      *            'APPLICABLE ONLY TO SQUARE MATRIX',
  79.      *            'MATRIX ALREADY EXITS',
  80.      *            'ILLEGAL VERSION NUMBER',
  81.      *            'MATRIX NOT FOUND',
  82.      *            'MATRIX IS NOT IN DATABASE FILE',
  83.      *            'NO SUCH VERSION',
  84.      *            'INCORE STORAGE OVERFLOW',
  85.      *            'CAN NOT SAVE IT INTO FILE, NVMAX=0',
  86.      *            'VERSION EXEEDS RESERVED',
  87.      *            'MATRIX IS NOT IN MAIN MEMORY',
  88.      *            'DATABASE NOT OPENED',
  89.      *            'DATABASE NUMBER IS OUT OF RANGE',
  90.      *            'MASTER DATABASE MUST BE OPENED FIRST',
  91.      *            'RENAME TO AN EXISTING ARRAY',
  92.      *            'OUT-OF-CORE VERSIONS ARE REMOVED',
  93.      *            'ARRAYS ARE NOT CONSISTENT',
  94.      *            'TEXT FILE NOT FOUND'/
  95.       WRITE(NTM,10) RTN, ND, DBNAME(ND)
  96. 10    FORMAT(' AMS ERROR OCCURS IN SUBROUTINE - ',A/
  97.      *       ' DATABASE ',I2,' : ',A)
  98.       IF (NCODE.GE.1.AND.NCODE.LE.NERROR) THEN
  99.          IF (NV.EQ.0.AND.NAME.NE.' ') THEN
  100.             WRITE(NTM,20) NAME,ERRMSG(NCODE)
  101.          ELSE IF (NV.NE.0.AND.NAME.NE.' ') THEN
  102.             WRITE(NTM,30) NAME,NV,ERRMSG(NCODE)
  103.          ELSE
  104.             WRITE(NTM,40) ERRMSG(NCODE)
  105.          ENDIF
  106.          CALL DBCLOS(1,'SAVE')
  107.       ENDIF
  108.       STOP 'AMS ABORTED.'
  109. 20    FORMAT(' ARRAY: ',A,' MESSAGE: ',A)
  110. 30    FORMAT(' ARRAY: ',A,', VERSION ',I3,' MESSAGE: ',A)
  111. 40    FORMAT(' MESSAGE: ',A)
  112.       END
  113. C
  114.       SUBROUTINE PACK( NAME,INAME )
  115.       IMPLICIT INTEGER*4(I-N)
  116. C ... LEVEL 0: CONVERT ARRAY NAME INTO 4 INTEGERS
  117.       DIMENSION INAME(1)
  118.       CHARACTER NAME*(*)
  119.       CALL UPCASE(NAME)
  120.       DO 10 I=1,4
  121. 10    INAME(I) = ICHAR(' ')
  122.       DO 20 I=1,LEN(NAME)
  123. 20    INAME(I) = ICHAR(NAME(I:I))
  124.       RETURN
  125.       END
  126. C
  127.       SUBROUTINE ICLEAR( LA, N )
  128.       IMPLICIT INTEGER*4(I-N)
  129. C ... LEVEL 0: CLEAR INTEGER ARRAY LA USING LOOP UNROLLING
  130.       DIMENSION LA(1)
  131.       M = N / 10
  132.       L = MOD(N,10)
  133.       DO 10 I = 1, L
  134. 10    LA(I) = 0
  135.       I = L + 1
  136.       IF (M.EQ.0) RETURN
  137.       DO 20 J = 1, M
  138.          LA(I)   = 0
  139.          LA(I+1) = 0
  140.          LA(I+2) = 0
  141.          LA(I+3) = 0
  142.          LA(I+4) = 0
  143.          LA(I+5) = 0
  144.          LA(I+6) = 0
  145.          LA(I+7) = 0
  146.          LA(I+8) = 0
  147.          LA(I+9) = 0
  148.          I       = I + 10
  149. 20    CONTINUE
  150.       RETURN
  151.       END
  152. C
  153.       SUBROUTINE DUPLIC( LA, LB, N )
  154.       IMPLICIT INTEGER*4(I-N)
  155. C ... LEVEL 0: DUPLICATE ARRAY LA TO LB USING LOOP UNROLLING
  156.       DIMENSION LA(1),LB(1)
  157.       M = N / 10
  158.       L = MOD(N,10)
  159.       DO 10 I=1,L
  160. 10    LB(I) = LA(I)
  161.       I = L + 1
  162.       IF (M.EQ.0) RETURN
  163.       DO 20 J=1,M
  164.          LB(I)   = LA(I)
  165.          LB(I+1) = LA(I+1)
  166.          LB(I+2) = LA(I+2)
  167.          LB(I+3) = LA(I+3)
  168.          LB(I+4) = LA(I+4)
  169.          LB(I+5) = LA(I+5)
  170.          LB(I+6) = LA(I+6)
  171.          LB(I+7) = LA(I+7)
  172.          LB(I+8) = LA(I+8)
  173.          LB(I+9) = LA(I+9)
  174.          I       = I + 10
  175. 20    CONTINUE
  176.       RETURN
  177.       END
  178. C
  179.       SUBROUTINE XFER(IP,NT,NR,NC,MS,NVMAX,NVW,
  180.      *                IREC,IOFF,LOC,NSIZE,NDROP)
  181.       IMPLICIT INTEGER*4(I-N)
  182. C ... LEVEL 0: TRANSFER MATRIX ATTRIBUTES
  183.       COMMON  MAVAIL,IA(1)
  184.       NT    = IA(IP+5)
  185.       NR    = IA(IP+6)
  186.       NC    = IA(IP+7)
  187.       MS    = IA(IP+8)
  188.       NVMAX = IA(IP+9)
  189.       NVW   = IA(IP+10)
  190.       IREC  = IA(IP+11)
  191.       IOFF  = IA(IP+12)
  192.       LOC   = IA(IP+13)
  193.       NSIZE = IA(IP+14)
  194.       NDROP = IA(IP+15)
  195.       RETURN
  196.       END
  197. C
  198.       SUBROUTINE KEY(N,NKEY)
  199.       IMPLICIT INTEGER*4(I-N)
  200. C ... LEVEL 0: CONVERT N-TH ARRAY NAME FROM INTEGER TO STRING
  201.       CHARACTER  NKEY*(*)
  202.       COMMON MAVAIL,IA(1)
  203.       INCLUDE 'AMSCTL.INC'
  204.       IP = IDIR + (N-1)*LENDIR - 1
  205.       DO 10 I=1,5
  206. 10    NKEY(I:I) = CHAR(IA(IP+I))
  207.       RETURN
  208.       END
  209. C
  210.       INTEGER*4 FUNCTION NUMDIR()
  211.       IMPLICIT INTEGER*4(I-N)
  212. C ... LEVEL 0: CALCULATE NUMBER OF ARRAYS IN DATABASE
  213.       COMMON MAVAIL,IA(1)
  214.       INCLUDE 'AMSCTL.INC'
  215.       NUMDIR = (MAVAIL-IDIR+1)/LENDIR
  216.       RETURN
  217.       END
  218. C
  219.       INTEGER*4 FUNCTION LOOK(ND,NAME)
  220.       IMPLICIT INTEGER*4(I-N)
  221. C ... LEVEL 0: FIND THE DIRECTORY ENTRY POINT OF ARRAY 'NAME' BY
  222. C              SEQUENTIAL OR BINARY SEARCH
  223.       CHARACTER   NAME*(*),KEYMID*5,KEYX*5
  224.       DIMENSION   INAME(4)
  225.       COMMON MAVAIL,IA(1)
  226.       INCLUDE 'AMSCTL.INC'
  227.       CALL PACK(NAME,INAME)
  228.       I = 0
  229.       IF (ISORT.EQ.1) THEN
  230. C ... BINARY SEARCH
  231.         KEYX      = '     '
  232.         KEYX(1:1) = CHAR(ND)
  233.         DO 10 J=2,5
  234. 10      KEYX(J:J) = CHAR(INAME(J-1))
  235.         LOW = 1
  236.         NHIGH = NUMDIR()
  237. 20      IF (LOW.GT.NHIGH.OR.I.NE.0) GOTO 30
  238.            MID = (LOW+NHIGH) / 2
  239.            CALL KEY(MID,KEYMID)
  240.            IF (KEYMID.EQ.KEYX) THEN
  241.               I = MID
  242.            ELSE
  243.               IF (KEYMID.LT.KEYX) THEN
  244.                  LOW   = MID + 1
  245.               ELSE
  246.                  NHIGH = MID - 1
  247.               ENDIF
  248.            ENDIF
  249.         GOTO 20
  250. 30      IF (I.GT.0 ) THEN
  251.            LOOK = IDIR + (I-1)*LENDIR
  252.         ELSE
  253.            LOOK = 0
  254.         ENDIF
  255.       ELSE
  256. C ... SEQUENTIAL SEARCH
  257.         IP = IDIR
  258. 40      IF (IP.GE.MAVAIL.OR.I.NE.0) GOTO 50
  259.            IF(ND      .EQ.IA(IP)  ) THEN
  260.              IF(INAME(1).EQ.IA(IP+1)) THEN
  261.                IF(INAME(2).EQ.IA(IP+2)) THEN
  262.                  IF(INAME(3).EQ.IA(IP+3)) THEN
  263.                    IF(INAME(4).EQ.IA(IP+4)) THEN
  264.                      I = IP
  265.                    ENDIF
  266.                  ENDIF
  267.                ENDIF
  268.              ENDIF
  269.            ENDIF
  270.            IP = IP + LENDIR
  271.         GOTO 40
  272. 50      LOOK = I
  273.       ENDIF
  274.       RETURN
  275.       END
  276. C
  277.       INTEGER*4 FUNCTION MATLEN(NR,NC,NT,MS)
  278.       IMPLICIT INTEGER*4(I-N)
  279. C ... LEVEL 0:  CALCULATE THE MATRIX STORAGE USED
  280.       COMMON MAVAIL,IA(1)
  281.       INCLUDE 'AMSCTL.INC'
  282.       IF( MS.EQ.0) THEN
  283.          MATLEN = (NR*NC)*NDT(NT)
  284.       ELSE IF (MS.EQ.1) THEN
  285.          MATLEN = (NR*(NR+1)*NDT(NT)) / 2
  286.       ELSE IF (MS.EQ.2) THEN
  287.          MATLEN = NR*NDT(NT)
  288.       ELSE
  289.          MATLEN = 0
  290.       ENDIF
  291.       RETURN
  292.       END
  293. C
  294.       SUBROUTINE DSKADR( NSIZES,JREC, JOFF, IREC, IOFF )
  295.       IMPLICIT INTEGER*4(I-N)
  296. C ... LEVEL 0: FIND THE DISK ADDRESS AFTER ADVANCING NSIZES FROM
  297. C              (JREC,JOFF)
  298.       INCLUDE 'AMSCTL.INC'
  299.       NEOR = LENG - JOFF + 1
  300.       IF (NSIZES .LE. NEOR) THEN
  301.          IOFF = JOFF + NSIZES
  302.          IREC = JREC
  303.          IF ((IOFF-1).EQ.LENG) THEN
  304.             IOFF = 1
  305.             IREC = JREC + 1
  306.          ENDIF
  307.       ELSE
  308.          NS   = NSIZES - NEOR
  309.          IOFF = NS   - INT(NS/LENG)*LENG + 1
  310.          IREC = JREC + INT(NS/LENG) + 1
  311.       ENDIF
  312.       RETURN
  313.       END
  314. C
  315.       SUBROUTINE QFETCH( IP, NV, IAA)
  316.       IMPLICIT INTEGER*4(I-N)
  317. C ... LEVEL 0: QUICK DISK FETCH OF MATRIX WITH DIRECTORY ENTRY IP
  318.       COMMON  MAVAIL,IA(1)
  319.       INCLUDE 'AMSCTL.INC'
  320.       DIMENSION IAA(1)
  321. C     CALCULATE DISK ADDRESS
  322.       ND    = IA(IP)
  323.       NVW   = IA(IP+10)
  324.       NSIZE = IA(IP+14)
  325.       IF (NV.LE.0)    CALL ERROR(ND,'?',NV,7)
  326.       IF (NVW.LT.NV)  CALL ERROR(ND,'?',NV,10)
  327.       CALL DSKADR(NSIZE*(NV-1),IA(IP+11),IA(IP+12),JREC,JOFF)
  328.       READ(NDB(ND),REC=JREC) IBUFF
  329.       JJ = JOFF
  330.       DO 10 II=1,NSIZE
  331.          IAA(II) = IBUFF(JJ)
  332.          IF (JJ.EQ.LENG) THEN
  333.             JREC = JREC + 1
  334.             READ(NDB(ND),REC=JREC) IBUFF
  335.             JJ = 0
  336.          ENDIF
  337.          JJ = JJ + 1
  338. 10    CONTINUE
  339.       RETURN
  340.       END
  341. C
  342.       SUBROUTINE QSTORE(IP, NV, IAA)
  343.       IMPLICIT INTEGER*4(I-N)
  344. C ... LEVEL 0: QUICK DISK STORE OF MATRIX WITH DIRECTORY ENTRY IP
  345.       COMMON  MAVAIL,IA(1)
  346.       INCLUDE 'AMSCTL.INC'
  347.       DIMENSION IAA(1)
  348. C ... CALCULATE DISK ADDRESS
  349.       ND    = IA(IP)
  350.       NVW   = IA(IP+10)
  351.       NSIZE = IA(IP+14)
  352.       CALL DSKADR(NSIZE*(NV-1),IA(IP+11),IA(IP+12),JREC,JOFF)
  353.       CALL DSKADR(NSIZE*NV,    IA(IP+11),IA(IP+12),KREC,KOFF)
  354.       READ(NDB(ND),REC=JREC) IBUFF
  355.       JJ = JOFF
  356.       DO 10 II=1,NSIZE
  357.          IBUFF(JJ) = IAA(II)
  358.          IF (JJ.EQ.LENG) THEN
  359.             WRITE(NDB(ND),REC=JREC) IBUFF
  360.             JREC = JREC + 1
  361.             IF (JREC.EQ.KREC)  READ(NDB(ND),REC=JREC) IBUFF
  362.             JJ = 0
  363.          ENDIF
  364.          JJ = JJ + 1
  365. 10    CONTINUE
  366.       WRITE(NDB(ND),REC=JREC) IBUFF
  367.       IF (NV.GT.NVW) IA(IP+10) = NV
  368.       RETURN
  369.       END
  370. C
  371.       SUBROUTINE DSORT
  372.       IMPLICIT INTEGER*4(I-N)
  373. C ... LEVEL 1: SORT MATRIX NAMES IN DIRECTORY
  374.       COMMON MAVAIL,IA(1)
  375.       INCLUDE 'AMSCTL.INC'
  376.       CHARACTER*5 KEYJ,KEYK
  377. C ... BEGIN SELECTION SORT
  378.       N = NUMDIR()
  379.       IF (N.LE.0) RETURN
  380.       DO 30 I=1,N-1
  381.          K = I
  382.          CALL KEY(K,KEYK)
  383.          DO 10 J=I+1,N
  384.             CALL KEY(J,KEYJ)
  385.             IF (KEYJ.LT.KEYK ) THEN
  386.                K = J
  387.                KEYK = KEYJ
  388.             ENDIF
  389. 10       CONTINUE
  390. C ...    SWAP
  391.          IF (I.NE.K) THEN
  392.             IP1 = IDIR + (I-1)*LENDIR
  393.             IP2 = IDIR + (K-1)*LENDIR
  394.             DO 20 J=0,LENDIR-1
  395.                IT        = IA(IP1+J)
  396.                IA(IP1+J) = IA(IP2+J)
  397.                IA(IP2+J) = IT
  398. 20          CONTINUE
  399.          ENDIF
  400. 30    CONTINUE
  401.       ISORT = 1
  402.       RETURN
  403.       END
  404. C
  405.       SUBROUTINE MATCHK(ND,NAME,NT,MS,NR,NC)
  406.       IMPLICIT INTEGER*4(I-N)
  407. C ... LEVEL 0: CHECK MATRIX PARAMETERS
  408.       CHARACTER  NAME*(*)
  409.       IF (NT.LT.0.OR.NT.GT.2) CALL ERROR(ND,NAME,0,1)
  410.       IF (MS.LT.0.OR.MS.GT.2) CALL ERROR(ND,NAME,0,2)
  411.       IF (NR .LE. 0 )         CALL ERROR(ND,NAME,0,3)
  412.       IF (NC .LE. 0 )         CALL ERROR(ND,NAME,0,4)
  413.       IF (MS.EQ.1.OR.MS.EQ.2) THEN
  414.          IF (NR .NE. NC)      CALL ERROR(ND,NAME,0,5)
  415.       ENDIF
  416.       RETURN
  417.       END
  418. C
  419.       SUBROUTINE MEMCHK( MODE )
  420.       IMPLICIT INTEGER*4(I-N)
  421. C ... LEVEL 1: SET INCORE MEMORY MONITOR TOGGLE
  422. C              MODE = 'PASSIVE': LET THE USER PROGRAM MAKES DECISION
  423. C                                IF OUT OF MEMORY
  424. C                   = 'ACTIVE' : AMS ABORTED IF OUT OF MEMORY (DEFAULT)
  425.       CHARACTER*(*) MODE
  426.       INCLUDE 'AMSCTL.INC'
  427.       CALL UPCASE(MODE)
  428.       IF (MODE(1:1).EQ.'P') THEN
  429.          MCK = 1
  430.       ELSE
  431.          MCK = 0
  432.       ENDIF
  433.       END
  434. C
  435.       SUBROUTINE DEFINE( ND, NAME, NVMAX, NT, NR, NC, MS, LOC )
  436.       IMPLICIT INTEGER*4(I-N)
  437. C ... LEVEL 1: DEFINE A MATRIX
  438. C              NAME  = NAME OF THE MATRIX
  439. C              NVMAX = MAX. VERSION NUMBERS
  440. C              NT    = DATA TYPE: INTEGER, REAL,.OR.COMPLEX
  441. C              NR    = NUMBER OF ROWS
  442. C              NC    = NUMBER OF COLUMNS
  443. C              MS    = STORAGE MODE: GENERAL, SYMMETRIC, DIAGONAL
  444. C              LOC   = INCORE LOCATION  (RETURNED)
  445.       DIMENSION INAME(4)
  446.       CHARACTER NAME*(*)
  447.       COMMON MAVAIL,IA(1)
  448.       INCLUDE 'AMSCTL.INC'
  449.       RTN = 'DEFINE'
  450.       IF(ND .LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  451. C ... CHECK MATRIX PROPERTIES
  452.       CALL MATCHK(ND,NAME,NT,MS,NR,NC)
  453.       CALL PACK(NAME,INAME)
  454.       IP = LOOK(ND,NAME)
  455.       IF(IP.GT.0 ) CALL ERROR(ND,NAME,0,6)
  456. C ... EVALUATE STORAGE REQUIREMENT
  457.       NSIZE    = MATLEN(NR,NC,NT,MS)
  458. C ... ASSIGN ARRAY ADDRESS
  459.       LOC      = NXTLOC
  460. C ... SET UP NEW DIRECTORY
  461.       IP = IDIR - LENDIR
  462.       IF (IP.LT.(NXTLOC+NSIZE)) THEN
  463.          IF (MCK.EQ.0) THEN
  464.             CALL ERROR(ND,NAME,0,11)
  465.          ELSE
  466.             LOC = 0
  467.          END IF
  468.       ELSE
  469.          NARY(ND) = NARY(ND) + 1
  470.          IDIR     = IDIR - LENDIR
  471.          NXTLOC   = NXTLOC + NSIZE
  472.       END IF
  473. C ... ALLOCATE DISK SPACE DO MATRIX
  474.       IF (NVMAX.GT.0) THEN
  475.          NSIZES = NSIZE*NVMAX
  476.          CALL DSKADR(NSIZES,NREC(ND),NOFF(ND),IREC,IOFF)
  477. C ...    CLEAR THE DISK SPACE
  478.          READ(NDB(ND),REC=NREC(ND)) IBUFF
  479.          CALL ICLEAR(IBUFF(NOFF(ND)),LENG-NOFF(ND)+1)
  480.          WRITE(NDB(ND),REC=NREC(ND)) IBUFF
  481.          CALL ICLEAR(IBUFF,NOFF(ND))
  482.          DO 10 I=NREC(ND)+1 , IREC
  483. 10       WRITE(NDB(ND),REC=I) IBUFF
  484.          IA(IP+11) = NREC(ND)
  485.          IA(IP+12) = NOFF(ND)
  486.          NREC(ND)  = IREC
  487.          NOFF(ND)  = IOFF
  488.       ELSE
  489.          IA(IP+11) = 0
  490.          IA(IP+12) = 0
  491.       ENDIF
  492. C ... STORE MATRIX PROPERTIES IN DIRECTORY
  493.       IA(IP  )  = ND
  494.       IA(IP+1)  = INAME(1)
  495.       IA(IP+2)  = INAME(2)
  496.       IA(IP+3)  = INAME(3)
  497.       IA(IP+4)  = INAME(4)
  498.       IA(IP+5)  = NT
  499.       IA(IP+6)  = NR
  500.       IA(IP+7)  = NC
  501.       IA(IP+8)  = MS
  502.       IA(IP+9)  = NVMAX
  503.       IA(IP+10) = 0
  504.       IA(IP+13) = LOC
  505.       IA(IP+14) = NSIZE
  506.       IA(IP+15) = 0
  507.       ISORT     = 0
  508.       RETURN
  509.       END
  510. C
  511.       SUBROUTINE LOCATE( ND,NAME, NT,NR,NC,MS,LOC )
  512.       IMPLICIT INTEGER*4(I-N)
  513. C ... LEVEL 1: LOCATE INCORE MATRIX ADDRESS OF MATRIX 'NAME'.
  514. C     RETURN   LOC=0      IF NOT FOUND,
  515. C              LOC=-NVMAX IF MATRIX 'NAME' IN OUT-OF-CORE DIRECT FILE
  516. C                         USER MUST USE GET('NAME',NV) TO RETRIEVE IT
  517. C                         IF ONLY ONE OUT-OF-CORE VERSION AVAILABLE,
  518. C                         THE VERSION IS AUTO ALLOCATED
  519. C              LOC<>0     LOCATION OF MATRIX 'NAME' STARTED FROM IA(LOC)
  520.       CHARACTER NAME*(*)
  521.       COMMON MAVAIL,IA(1)
  522.       INCLUDE 'AMSCTL.INC'
  523.       RTN = 'LOCATE'
  524.       IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  525.       IP = LOOK(ND,NAME)
  526.       IF (IP.GT.0) THEN
  527.          NT  = IA(IP+5)
  528.          NR  = IA(IP+6)
  529.          NC  = IA(IP+7)
  530.          MS  = IA(IP+8)
  531.          LOC = IA(IP+13)
  532.          IF (LOC .LE. 0 ) LOC = -IA(IP+9)
  533. C ...    CHECK IF ONLY ONE OUT-OF-CORE VERSION EXISTS
  534. C         IF (LOC.EQ.-1) THEN
  535. C ...       ALLOCATE INCORE STORAGE
  536. C            LOC    = NXTLOC
  537. C            NXTLOC = NXTLOC + IA(IP+14)
  538. C            IF (IDIR.LT.NXTLOC) CALL ERROR(ND,NAME,NV,11)
  539. C            IA(IP+13) = LOC
  540. C ...       QUICH FETCH THE MATRIX
  541. C            CALL QFETCH(IP,1,IA(LOC))
  542. C         ENDIF
  543.       ELSE
  544.          LOC = 0
  545.       ENDIF
  546.       RETURN
  547.       END
  548. C
  549.       SUBROUTINE ATTRIB( ND,NAME,NVMAX,NT,NR,NC,MS,LOC,
  550.      *                   NVW,IREC,IOFF,NSIZE,NDROP)
  551.       IMPLICIT INTEGER*4(I-N)
  552. C ... LEVEL 1:  ASK FULL MATRIX ATTRIBUTES IN THE DATABASE ND
  553.       CHARACTER NAME*(*)
  554.       INCLUDE 'AMSCTL.INC'
  555.       RTN = 'ATTRIB'
  556.       LOC    = 0
  557.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  558.       IF (NOPEN(ND).EQ.0)         CALL ERROR(ND,NAME,0,15)
  559.       IP  = LOOK(ND,NAME)
  560.       IF (IP.GT.0) THEN
  561.          CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  562.          IF (LOC.LE.0) LOC = -NVMAX
  563.       ENDIF
  564.       RETURN
  565.       END
  566. C
  567.       SUBROUTINE RENAME( ND,OLDNAM, NEWNAM)
  568.       IMPLICIT INTEGER*4(I-N)
  569. C ... LEVEL 1: CHANGE MATRIX NAME FROM 'OLDNAM' TO 'NEWNAM'
  570.       CHARACTER*(*) OLDNAM, NEWNAM
  571.       DIMENSION INAME2(4)
  572.       COMMON  MAVAIL,IA(1)
  573.       INCLUDE 'AMSCTL.INC'
  574.       RTN = 'RENAME'
  575.       IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,OLDNAM,0,16)
  576.       IP = LOOK(ND,OLDNAM)
  577.       IF (IP.LE.0 ) CALL ERROR(ND,OLDNAM,0,8)
  578.       IP1 = LOOK(ND,NEWNAM)
  579.       IF (IP1.GT.0) CALL ERROR(ND,NEWNAM,0,18)
  580.       CALL PACK(NEWNAM,INAME2)
  581.       DO 10 I=1,4
  582. 10    IA(IP+I) = INAME2(I)
  583.       ISORT = 0
  584.       RETURN
  585.       END
  586. C
  587.       SUBROUTINE DELETE( ND, NAME )
  588.       IMPLICIT INTEGER*4(I-N)
  589. C ... LEVEL 1: DELETE AN INCORE MATRIX 'NAME' OF DATABASE ND
  590.       CHARACTER NAME*(*)
  591.       COMMON MAVAIL,IA(1)
  592.       INCLUDE 'AMSCTL.INC'
  593.       RTN = 'DELETE'
  594.       IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  595.       IP = LOOK(ND,NAME)
  596.       IF (IP.GT.0.AND.IA(IP+13).GT.0) THEN
  597. C ...    THE MATRIX IS IN MAIN MEMORY GET MATRIX ATTRIBUTES
  598.          NVMAX = IA(IP+9)
  599.          LOC   = IA(IP+13)
  600.          NSIZE = IA(IP+14)
  601.          NXTLOC= NXTLOC - NSIZE
  602. C ...    IS THE MATRIX NOT IN THE LAST POSITION ?
  603.          IF (LOC .LT. NXTLOC) THEN
  604. C ...       COMPACT STORAGE
  605.             CALL DUPLIC( IA(LOC+NSIZE), IA(LOC), NXTLOC-LOC )
  606.          ENDIF
  607. C ...    SET THE NEW LOCATION FOR ALL INCORE MATRICES
  608.          IF (NVMAX.GT.0) THEN
  609. C ...       KEEP THE DIRECTORY, SET LOCATION , ZERO
  610.             IA(IP+13) = 0
  611.          ELSE
  612. C ...       DELETE THE DIRECTORY AND MOVE REMAINDER TO NEW LOCATION
  613.             I = IP - 1
  614.             DO 10 J=IP+LENDIR-1,IDIR+LENDIR-1,-1
  615.                IA(J) = IA(I)
  616.                I = I - 1
  617. 10          CONTINUE
  618.             NARY(ND) = NARY(ND) - 1
  619.             IDIR     = IDIR + LENDIR
  620.          ENDIF
  621. C ...    UPDATE MATRIX LOCATION IN DIRECTORY, LOC IN DIR 13
  622.          I = IDIR + 13
  623.          DO 20 J=1,NUMDIR()
  624.             IF (IA(I).GT.LOC ) IA(I) = IA(I) - NSIZE
  625.             I = I + LENDIR
  626. 20       CONTINUE
  627.       ENDIF
  628.       RETURN
  629.       END
  630. C
  631.       SUBROUTINE DELALL( ND )
  632.       IMPLICIT INTEGER*4(I-N)
  633. C ... LEVEL 1: DELETE ALL INCORE MATRICES OF DATABASE ND
  634.       CHARACTER*4 NAME
  635.       COMMON MAVAIL,IA(1)
  636.       INCLUDE 'AMSCTL.INC'
  637.       RTN = 'DELALL'
  638.       IF(ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  639. C ... RELEASE ALL MAIN MEMORY ALLOCATED BY MATRICES
  640.       IP = MAVAIL - LENDIR + 1
  641. 10    IF (IP.LT.IDIR) RETURN
  642.          IF (IA(IP).EQ.ND.AND.IA(IP+13).GT.0) THEN
  643.             DO 20 J=1,4
  644. 20          NAME(J:J) = CHAR(IA(IP+J))
  645.             CALL DELETE(ND,NAME)
  646.          ELSE
  647.             IP = IP - LENDIR
  648.          ENDIF
  649.       GOTO 10
  650.       END
  651. C
  652.       SUBROUTINE GET( ND, NAME, NV, LOC )
  653.       IMPLICIT INTEGER*4(I-N)
  654. C ... LEVEL 1: GET MATRIX 'NAME' FROM DATABASE ND
  655.       CHARACTER NAME*(*)
  656.       COMMON    MAVAIL,IA(1)
  657.       INCLUDE 'AMSCTL.INC'
  658.       RTN = 'GET'
  659.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  660.       IP = LOOK(ND,NAME)
  661.       IF (IP.EQ.0) CALL ERROR(ND,NAME,0,8)
  662.       CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  663.       IF (NVMAX.EQ.0) CALL ERROR(ND,NAME,NV,9)
  664.       IF (LOC.EQ.0) THEN
  665. C ...    ALLOCATE INCORE STORAGE
  666.          LOC    = NXTLOC
  667.          NXTLOC = NXTLOC + NSIZE
  668.          IF (IDIR.LT.NXTLOC) CALL ERROR(ND,NAME,NV,11)
  669.          IA(IP+13) = LOC
  670.       ENDIF
  671. C ... QUICH FETCH THE MATRIX
  672.       CALL QFETCH(IP,NV,IA(LOC))
  673.       RETURN
  674.       END
  675. C
  676.       SUBROUTINE SAVE( ND, NAME, NV )
  677.       IMPLICIT INTEGER*4(I-N)
  678. C ... LEVEL 1: SAVE MATRIX 'NAME' INTO DATABASE ND
  679.       CHARACTER NAME*(*)
  680.       COMMON MAVAIL,IA(1)
  681.       INCLUDE 'AMSCTL.INC'
  682.       RTN = 'SAVE'
  683.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  684.       IF (NV.LE.0) CALL ERROR(ND,NAME,NV,7)
  685.       IP = LOOK(ND,NAME)
  686.       IF (IP.EQ.0) CALL ERROR(ND,NAME,NV,8)
  687.       CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  688.       IF (NVMAX.EQ.0)  CALL ERROR(ND,NAME,NV,12)
  689.       IF (NVMAX.LT.NV) CALL ERROR(ND,NAME,NV,13)
  690.       IF (LOC.EQ.0)    CALL ERROR(ND,NAME,NV,14)
  691. C ... QUICK STORE THE MATRIX
  692.       CALL QSTORE(IP,NV,IA(LOC))
  693.       RETURN
  694.       END
  695. C
  696.       SUBROUTINE REMOVE( ND, NAME )
  697.       IMPLICIT INTEGER*4(I-N)
  698. C ... LEVEL 1: MARK DELETION OF MATRIX 'NAME', THE DIRECTORY WILL BE
  699. C              REMOVED NO MATTER THE MATRIX IS INCORE OR OUT-OF-CORE,
  700. C              BUT THE DISK SPACE DID'NT SHRINK AFTER REMOVED, JUST
  701. C              LEAVE THE FRAGMENT THERE
  702.       CHARACTER NAME*(*)
  703.       COMMON MAVAIL,IA(1)
  704.       INCLUDE 'AMSCTL.INC'
  705.       RTN = 'REMOVE'
  706.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  707.       IP  = LOOK(ND,NAME)
  708.       IF (IP.EQ.0 ) CALL ERROR(ND,NAME,0,8)
  709.       LOC = IA(IP+13)
  710.       IF (LOC.GT.0) CALL DELETE(ND,NAME)
  711.       IA(IP+14) = 1
  712.       RETURN
  713.       END
  714. C
  715.       SUBROUTINE COPY( ND1, NAME1, ND2, NAME2 )
  716.       IMPLICIT INTEGER*4(I-N)
  717. C ... LEVEL 1: COPY AN INCORE MATRIX 'NAME1' IN DATABASE ND1 TO THE
  718. C              ICORE MATRIX 'NAME2' OF DATABASE ND2.
  719.       CHARACTER*(*) NAME1, NAME2
  720.       COMMON   MAVAIL,IA(1)
  721.       INCLUDE 'AMSCTL.INC'
  722.       RTN = 'COPY'
  723.       IF(ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
  724.       IF(ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
  725.       CALL LOCATE(ND1,NAME1,NT1,NR1,NC1,MS1,LOC1)
  726.       IF (LOC1 .LE. 0 ) RETURN
  727. C ... EVALUATE STORAGE REQUIREMENT
  728.       NSIZE = MATLEN(NR1,NC1,NT1,MS1)
  729.       CALL LOCATE(ND2,NAME2,NT2,NR2,NC2,MS2,LOC2)
  730.       IF (LOC2.EQ.0) THEN
  731. C ...    MATRIX 2 IS.NOT.EXIST, CREATE AN INCORE ONE
  732.          NT2 = NT1
  733.          NR2 = NR1
  734.          NC2 = NC1
  735.          MS2 = MS1
  736.          CALL DEFINE(ND2,NAME2,0,NT1,NR1,NC1,MS1,LOC2)
  737.       ELSE IF(LOC2.LT.0) THEN
  738. C ...    MATRIX 2 EXIST, BUT.NOT.AN INCORE ONE
  739.          CALL GET(ND2,NAME2,1,LOC2)
  740.       ENDIF
  741. C ... CHECK COMPATIBILITY
  742.       IF((NT1.NE.NT2).OR.(NR1.NE.NR2).OR.
  743.      *   (NC1.NE.NC2).OR.(MS1.NE.MS2))  RETURN
  744. C ... COPY
  745.       CALL DUPLIC( IA(LOC1), IA(LOC2), NSIZE )
  746.       ISORT = 0
  747.       RETURN
  748.       END
  749. C
  750.       SUBROUTINE FETCH( ND, NAME, NV, IAA)
  751.       IMPLICIT INTEGER*4(I-N)
  752. C ... LEVEL 1: COPY AN OUT-OF-CORE MATRIX 'NAME' VERSION NV IN DATABASE
  753. C              ND TO THE INCORE MATRIX 'AA'.
  754.       DIMENSION IAA(1)
  755.       CHARACTER NAME*(*)
  756.       INCLUDE 'AMSCTL.INC'
  757.       RTN = 'FETCH'
  758.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  759.       IP = LOOK(ND,NAME)
  760.       IF (IP.EQ.0 ) CALL ERROR(ND,NAME,NV,8)
  761.       CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  762.       IF (NVMAX.EQ.0 ) CALL ERROR(ND,NAME,NV,9)
  763. C ... QUICK FETCH THE MATRIX
  764.       CALL QFETCH(IP,NV,IAA)
  765.       RETURN
  766.       END
  767. C
  768.       SUBROUTINE STORE( ND, NAME, NV, IAA )
  769.       IMPLICIT INTEGER*4(I-N)
  770. C ... LEVEL 1: STORE INCORE MATRIX 'AA' INTO MATRIX 'NAME' VERSION NV OF
  771. C              DATABASE ND
  772.       DIMENSION IAA(1)
  773.       CHARACTER NAME*(*)
  774.       COMMON  MAVAIL,IA(1)
  775.       INCLUDE 'AMSCTL.INC'
  776.       RTN = 'STORE'
  777.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  778.       IF (NV.LE.0) CALL ERROR(ND,NAME,NV,7)
  779.       IP = LOOK(ND,NAME)
  780.       IF (IP.EQ.0 ) CALL ERROR(ND,NAME,NV,8)
  781.       CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  782.       IF (NVMAX.EQ.0  ) CALL ERROR(ND,NAME,NV,12)
  783.       IF (NVMAX.LT.NV ) CALL ERROR(ND,NAME,NV,13)
  784. C ... QUICK STORE THE MATRIX
  785.       CALL QSTORE(IP,NV,IAA)
  786.       RETURN
  787.       END
  788. C
  789.       SUBROUTINE MOVE(ND1,NAME1,ND2,NAME2)
  790.       IMPLICIT INTEGER*4(I-N)
  791. C ... LEVEL 1: COPY OUT-OF-CORE ARRAY (ND1,NAME1) TO (ND2,NAME2)
  792.       COMMON  MAVAIL,IA(1)
  793.       INCLUDE 'AMSCTL.INC'
  794.       CHARACTER  NAME1*(*),NAME2*(*)
  795.       RTN = 'MOVE'
  796.       IF (ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
  797.       IF (ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
  798.       IP1 = LOOK(ND1,NAME1)
  799.       IF (IP1.LE.0) CALL ERROR(ND1,NAME1,0,8)
  800.       CALL XFER(IP1,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  801.       IF (NVMAX.LE.0) CALL ERROR(ND1,NAME1,0,9)
  802.       IF (NDROP.GT.0) CALL ERROR(ND1,NAME1,0,19)
  803.       IP2 = LOOK(ND2,NAME2)
  804.       IF (IP2.LE.0) THEN
  805.          CALL DEFINE(ND2,NAME2,NVMAX,NT,NR,NC,MS,IX)
  806.          IP2 = LOOK(ND2,NAME2)
  807.       ELSE
  808.          CALL XFER(IP2,NT2,NR2,NC2,MS2,NVMAX2,NVW,IREC,IOFF,
  809.      *             LOC,NSIZE,NDROP)
  810.          IF (NT.NE.NT2.OR.NR.NE.NR2.OR.NC.NE.NC2.OR.MS.NE.MS2.OR.
  811.      *       NVMAX.GT.NVMAX2) CALL ERROR(ND1,NAME1,0,20)
  812.          IF (LOC.LE.0) CALL GET(ND2,NAME2,1,IX)
  813.       ENDIF
  814. C ... MOVE IT
  815.       IX = IA(IP2+13)
  816.       IF (IX.LE.0) CALL ERROR(ND2,NAME2,0,11)
  817.       DO 10 I=1,NVMAX
  818.          CALL QFETCH(IP1,I,IA(IX))
  819.          CALL QSTORE(IP2,I,IA(IX))
  820. 10    CONTINUE
  821.       RETURN
  822.       END
  823. C
  824.       SUBROUTINE MOVE1V(ND1,NAME1,NV1,ND2,NAME2,NV2)
  825.       IMPLICIT INTEGER*4(I-N)
  826. C ... LEVEL 1: COPY ONE VERSION OF OUT-OF-CORE ARRAY (ND1,NAME1,NV1) TO
  827. C              (ND2,NAME2,NV2)
  828.       COMMON  MAVAIL,IA(1)
  829.       INCLUDE 'AMSCTL.INC'
  830.       CHARACTER  NAME1*(*),NAME2*(*)
  831.       RTN = 'MOVE1V'
  832.       IF (ND1.LE.0.OR.ND1.GT.NDATA) CALL ERROR(ND1,NAME1,0,16)
  833.       IF (ND2.LE.0.OR.ND2.GT.NDATA) CALL ERROR(ND2,NAME2,0,16)
  834.       IP1 = LOOK(ND1,NAME1)
  835.       IF (IP1.LE.0) CALL ERROR(ND1,NAME1,0,8)
  836.       CALL XFER(IP1,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  837.       IF (NVW.LT.NV1) CALL ERROR(ND1,NAME1,0,10)
  838.       IF (NDROP.GT.0) CALL ERROR(ND1,NAME1,0,19)
  839.       IP2 = LOOK(ND2,NAME2)
  840.       IF (IP2.LE.0) THEN
  841.          CALL DEFINE(ND2,NAME2,NVMAX,NT,NR,NC,MS,IX)
  842.          IP2 = LOOK(ND2,NAME2)
  843.       ELSE
  844.          CALL XFER(IP2,NT2,NR2,NC2,MS2,NVMAX2,NVW,IREC,IOFF,
  845.      *             LOC,NSIZE,NDROP)
  846.          IF (NT.NE.NT2.OR.NR.NE.NR2.OR.NC.NE.NC2.OR.MS.NE.MS2.OR.
  847.      *       NVMAX.GT.NVMAX2) CALL ERROR(ND1,NAME1,0,20)
  848.          IF (NVMAX2.LT.NV2)  CALL ERROR(ND2,NAME2,NV2,13)
  849.          IF (LOC.LE.0) CALL GET(ND2,NAME2,1,IX)
  850.       ENDIF
  851. C ... MOVE IT
  852.       IX = IA(IP2+13)
  853.       IF (IX.LE.0) CALL ERROR(ND2,NAME2,0,11)
  854.       CALL QFETCH(IP1,NV1,IA(IX))
  855.       CALL QSTORE(IP2,NV2,IA(IX))
  856.       RETURN
  857.       END
  858. C
  859.       SUBROUTINE DBCOPY(ND1,ND2)
  860.       IMPLICIT INTEGER*4(I-N)
  861. C ... LEVEL 1: COPY ENTIRE OUT-OF-CORE ARRAYS FROM ND1 TO ND2
  862.       COMMON  MAVAIL,IA(1)
  863.       INCLUDE 'AMSCTL.INC'
  864.       CHARACTER  NAME*4
  865.       RTN = 'DBCOPY'
  866.       N   = NUMDIR()
  867.       IP  = IDIR
  868.       DO 30 I=1,N
  869.          ND   = IA(IP)
  870.          IF (ND.NE.ND1) GO TO 15
  871.          NAME = '    '
  872.          DO 10 J=1,4
  873. 10       NAME(J:J) = CHAR(IA(IP+J))
  874.          CALL MOVE(ND1,NAME,ND2,NAME)
  875. 15       IP   = IP + LENDIR
  876. 30    CONTINUE
  877.       RETURN
  878.       END
  879. C
  880.       SUBROUTINE GETDIR(ND,NDIR)
  881.       IMPLICIT INTEGER*4(I-N)
  882. C ... LEVEL 0: GET DIRECTORY INFORMATION FROM AN 'OLD' DATABASE
  883.       COMMON MAVAIL,IA(1)
  884.       INCLUDE 'AMSCTL.INC'
  885.       IF (ND.EQ.1) THEN
  886.          IDIR = MAVAIL - NARY(ND)*LENDIR + 1
  887.          IS   = MAVAIL
  888.       ELSE
  889.          IS   = IDIR - 1
  890.          IDIR = IDIR - NARY(ND)*LENDIR
  891.       ENDIF
  892.       IF (IDIR.LT.NXTLOC ) CALL ERROR(ND,'OPEN',0,11)
  893. C ... GET DIRECTORY
  894.       NSDIR = NDIR
  895.       II    = IDIR
  896.       JJ    = 1
  897.       READ(NDB(ND),REC=NSDIR) IBUFF
  898. 10    IF ( II .GT. IS ) GOTO 20
  899.          IA(II) = IBUFF(JJ)
  900.          IF (JJ.EQ.LENG)THEN
  901.             NSDIR = NSDIR + 1
  902.             READ(NDB(ND),REC=NSDIR) IBUFF
  903.             JJ = 0
  904.          ENDIF
  905.          JJ = JJ + 1
  906.          II = II + 1
  907.       GOTO 10
  908. C ... SET DATABASE INDICATOR
  909. 20    II = IDIR
  910. 30    IF ( II.GE.IS) RETURN
  911.          IA(II) = ND
  912.          II = II + LENDIR
  913.       GOTO 30
  914.       END
  915.  
  916.       SUBROUTINE UPCASE(STRING)
  917.       IMPLICIT INTEGER*4(I-N)
  918.       CHARACTER  STRING*(*),CH*1
  919. C ... LEVEL 0: CONVERT LOWER CASE TO UPPER CASE
  920.       DO 10 I=1,LEN(STRING)
  921.       CH = STRING(I:I)
  922.       IF (CH.GE.'a'.AND.CH.LE.'z') THEN
  923.          STRING(I:I) = CHAR( ICHAR(CH) - ICHAR('a') + ICHAR('A') )
  924.       ENDIF
  925. 10    CONTINUE
  926.       RETURN
  927.       END
  928. C
  929.       SUBROUTINE DBOPEN( ND, FNAME, STATE )
  930.       IMPLICIT INTEGER*4(I-N)
  931. C ... LEVEL 1:  OPEN DATABASE
  932.       CHARACTER*(*) FNAME, STATE
  933.       COMMON MAVAIL,IA(1)
  934.       INCLUDE 'AMSCTL.INC'
  935.       RTN = 'DBOPEN'
  936.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL  ERROR(ND,' ',0,16)
  937.       IF (ND.EQ.1 ) CALL INIT
  938.       IF (ND.GT.1) THEN
  939.          IF (NOPEN(1).EQ.0 ) CALL ERROR(ND,' ',0,17)
  940.       ENDIF
  941.       IF(NOPEN(ND).EQ.1) RETURN
  942. C ... CHECK DATABASE FILE STATUS
  943.       CALL UPCASE(STATE)
  944.       CALL UPCASE(FNAME)
  945.       IF (STATE.NE.'NEW'.AND.STATE.NE.'OLD') STATE = 'UNKNOWN'
  946.       IF (STATE.EQ.'UNKNOWN') THEN
  947.          OPEN(NDB(ND),FILE=FNAME,STATUS='OLD',ERR=10)
  948.          STATE = 'OLD'
  949.          CLOSE(NDB(ND))
  950.          GOTO 20
  951. 10       STATE = 'NEW'
  952. 20       CONTINUE
  953.       ENDIF
  954.       IF (STATE.EQ.'NEW') THEN
  955.          CALL CLOCK(KCTM(1,ND))
  956.          KATM(1,ND) = KCTM(1,ND)
  957.          KATM(2,ND) = KCTM(2,ND)
  958.          KATM(3,ND) = KCTM(3,ND)
  959.          KATM(4,ND) = KCTM(4,ND)
  960.          KATM(5,ND) = KCTM(5,ND)
  961.          KATM(6,ND) = KCTM(6,ND)
  962.          NARY(ND)   = 0
  963.          NREC(ND)   = 2
  964.          NOFF(ND)   = 1
  965.          DO 30 I=1,LENG
  966. 30       IBUFF(I) = 0
  967.          OPEN(NDB(ND),FILE=FNAME,ACCESS='DIRECT',RECL=LENG*INTL,
  968.      *                STATUS='UNKNOWN')
  969.          WRITE(NDB(ND),REC=1) IBUFF
  970.          WRITE(NDB(ND),REC=2) IBUFF
  971.       ELSE IF(STATE.EQ.'OLD') THEN
  972.          OPEN(NDB(ND),FILE=FNAME,ACCESS='DIRECT',RECL=LENG*INTL,
  973.      *                STATUS='OLD',IOSTAT=IOS,ERR=40)
  974. 40       IF (IOS.NE.0) THEN
  975.             WRITE(NTM,50) FNAME
  976. 50          FORMAT(' DATABASE FILE ',A,' NOT FOUND')
  977.             STOP
  978.          ENDIF
  979.          READ(NDB(ND),REC=1) IBUFF
  980.          NSDIR      = IBUFF(1)
  981.          NARY(ND)   = IBUFF(4)
  982.          NREC(ND)   = IBUFF(5)
  983.          NOFF(ND)   = IBUFF(6)
  984.          KCTM(1,ND) = IBUFF(7)
  985.          KCTM(2,ND) = IBUFF(8)
  986.          KCTM(3,ND) = IBUFF(9)
  987.          KCTM(4,ND) = IBUFF(10)
  988.          KCTM(5,ND) = IBUFF(11)
  989.          KCTM(6,ND) = IBUFF(12)
  990.          CALL CLOCK(KATM(1,ND))
  991.          CALL GETDIR(ND,NSDIR)
  992.       ENDIF
  993.       DBNAME(ND) = FNAME
  994.       NOPEN(ND)  = 1
  995.       ISORT      = 0
  996.       RETURN
  997.       END
  998. C
  999.       SUBROUTINE PUTDIR( ND )
  1000.       IMPLICIT INTEGER*4(I-N)
  1001. C ... LEVEL 0: SAVE MASTER CONTROL PARAMETERS AND DIRECTORY
  1002. C              OF DATABASE ND
  1003.       COMMON MAVAIL,IA(1)
  1004.       INCLUDE 'AMSCTL.INC'
  1005. C ... SAVE MASTER CONTROL PARAMETERS
  1006.       CALL CLOCK(KATM(1,ND))
  1007.       NSDIR     =  NREC(ND) + 1
  1008.       IBUFF(1)  =  NSDIR
  1009.       IBUFF(2)  =  LENG
  1010.       IBUFF(3)  =  LENDIR
  1011.       IBUFF(4)  =  NARY(ND)
  1012.       IBUFF(5)  =  NREC(ND)
  1013.       IBUFF(6)  =  NOFF(ND)
  1014.       IBUFF(7)  =  KCTM(1,ND)
  1015.       IBUFF(8)  =  KCTM(2,ND)
  1016.       IBUFF(9)  =  KCTM(3,ND)
  1017.       IBUFF(10) =  KCTM(4,ND)
  1018.       IBUFF(11) =  KCTM(5,ND)
  1019.       IBUFF(12) =  KCTM(6,ND)
  1020.       IBUFF(13) =  KATM(1,ND)
  1021.       IBUFF(14) =  KATM(2,ND)
  1022.       IBUFF(15) =  KATM(3,ND)
  1023.       IBUFF(16) =  KATM(4,ND)
  1024.       IBUFF(17) =  KATM(5,ND)
  1025.       IBUFF(18) =  KATM(6,ND)
  1026.       WRITE(NDB(ND),REC=1) IBUFF
  1027. C ... SAVE DIRECTORY
  1028.       N  = NUMDIR()
  1029.       II = IDIR
  1030.       JJ = 1
  1031.       DO 20 I=1,N
  1032.          IF (IA(II).EQ.ND) THEN
  1033.          DO 10 J=0,LENDIR-1
  1034.             IBUFF(JJ) = IA(II+J)
  1035.             IF (JJ.EQ.LENG) THEN
  1036.                WRITE(NDB(ND),REC=NSDIR) IBUFF
  1037.                NSDIR = NSDIR + 1
  1038.                JJ = 0
  1039.             ENDIF
  1040.             JJ = JJ + 1
  1041. 10       CONTINUE
  1042.          ENDIF
  1043.          II = II + LENDIR
  1044. 20    CONTINUE
  1045.       WRITE(NDB(ND),REC=NSDIR) IBUFF
  1046.       RETURN
  1047.       END
  1048. C
  1049.       SUBROUTINE DBCLOS( ND, STATE )
  1050.       IMPLICIT INTEGER*4(I-N)
  1051. C ... LEVEL 1: CLOSE DATABASE FILE
  1052.       CHARACTER STATE*(*)
  1053.       COMMON MAVAIL,IA(1)
  1054.       INCLUDE 'AMSCTL.INC'
  1055.       RTN = 'DBCLOS'
  1056.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,' ',0,16)
  1057. C ... CLEAR INCORE MATRICES
  1058.       CALL DELALL(ND)
  1059. C ... SAVE DIRECTORY
  1060.       CALL PUTDIR(ND)
  1061.       NOPEN(ND) = 0
  1062.       CALL UPCASE(STATE)
  1063.       IF (STATE.EQ.'DELETE' ) THEN
  1064.          CLOSE(NDB(ND),STATUS='DELETE')
  1065.       ELSE
  1066.          CLOSE(NDB(ND),STATUS='KEEP')
  1067.       ENDIF
  1068.       IF (ND.EQ.1) THEN
  1069.          DO 10 I=2,NDATA
  1070.          IF (NOPEN(I).EQ.1) THEN
  1071.             CALL DELALL(I)
  1072.             CALL PUTDIR(I)
  1073.             NOPEN(I) = 0
  1074.             IF (STATE.EQ.'DELETE' ) THEN
  1075.                CLOSE(NDB(I),STATUS='DELETE')
  1076.             ELSE
  1077.                CLOSE(NDB(I),STATUS='KEEP')
  1078.             ENDIF
  1079.          ENDIF
  1080. 10       CONTINUE
  1081.          CLOSE(NTM)
  1082.          CLOSE(NTR)
  1083.       ENDIF
  1084.       RETURN
  1085.       END
  1086. C
  1087.       SUBROUTINE MEMORY(NUDIR,NUSED,NFREE)
  1088.       IMPLICIT INTEGER*4(I-N)
  1089. C ... LEVEL 1: INQUIRE MEMORY BANK STATUS
  1090. C              NUDIR = MEMORY USED BY DIRECTORY
  1091. C              NUSED = MEMORY USED BY INCORE ARRAYS
  1092. C              NFREE = FREE MEMORY
  1093.       COMMON MAVAIL,IA(1)
  1094.       INCLUDE 'AMSCTL.INC'
  1095.       NUDIR = MAVAIL - IDIR + 1
  1096.       NUSED = NXTLOC - 1
  1097.       NFREE = IDIR - NXTLOC
  1098.       RETURN
  1099.       END
  1100. C
  1101.       SUBROUTINE DIR( LUN )
  1102.       IMPLICIT INTEGER*4(I-N)
  1103. C ... LEVEL 1: PRINT DIRECTORY TO LOGICAL UNIT NUMBER LUN
  1104.       COMMON MAVAIL,IA(1)
  1105.       INCLUDE 'AMSCTL.INC'
  1106.       DIMENSION NDTTM(6)
  1107.       CHARACTER TP(0:2)*4, S(0:2)*4, DRP(0:1)*3
  1108.       CHARACTER NAME*4, DSTAMP*31, DTTM*31
  1109.       DATA TP/'INT ','REAL','CMPX'/, S/'GEN.','SYMM','DIAG'/
  1110.       DATA DRP/' NO','YES'/
  1111. C
  1112.       IF (NOPEN(1).EQ.0) RETURN
  1113.       N = NUMDIR()
  1114.       CALL CLOCK(NDTTM)
  1115.       CALL DATES(NDTTM,DTTM)
  1116.       CALL DATES(KATM(1,1),DSTAMP)
  1117.       WRITE(LUN,10) '1', NVERSN, DTTM
  1118. 10    FORMAT(A/' ARRAY MANAGEMENT SYSTEM - FORTRAN VERSION ',I2.2,
  1119.      *         ' (C) 1989 BY TZONG-SHUOH YANG'/
  1120.      *         ' DIRECTORY LISTING DATE/TIME - ',A/)
  1121.       LINE = 5
  1122.       DO 30 I=1,NDATA
  1123.          IF (NOPEN(I).EQ.1) THEN
  1124.             CALL DATES(KCTM(1,I),DSTAMP)
  1125.             WRITE(LUN,20) I,DBNAME(I)(1:20),DSTAMP
  1126. 20          FORMAT(' DATABASE',I3,': ',A,'    CREATED - ',A)
  1127.             LINE = LINE + 1
  1128.          ENDIF
  1129. 30    CONTINUE
  1130.       IF (N.GT.0) THEN
  1131.         WRITE(LUN,40)
  1132. 40      FORMAT(/' DB NAME TYPE ROWS COLS MODE NVMAX  NVW',
  1133.      *          '   LOC.  REC. OFFSET  SIZE DEL'/
  1134.      *          ' -- ---- ---- ---- ---- ---- ----- -----',
  1135.      *          ' ----- ----- ------ ----- ---')
  1136.         IP = IDIR
  1137.         DO 75 I=1,N
  1138.            ND   = IA(IP)
  1139.            NAME = '    '
  1140.            DO 60 J=1,4
  1141. 60         NAME(J:J) = CHAR(IA(IP+J))
  1142.            CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  1143.            IF (LINE.GE.LIMIT) THEN
  1144.               WRITE(LUN,10) '1',NVERSN,DTTM
  1145.               WRITE(LUN,40)
  1146.               LINE = 5
  1147.            ENDIF
  1148.            WRITE(LUN,70) ND,NAME,TP(NT),NR,NC,S(MS),NVMAX,NVW,
  1149.      *                   LOC,IREC,IOFF,NSIZE,DRP(NDROP)
  1150. 70         FORMAT(I3,2A5,2I5,A5,4I6,I7,I6,1X,A)
  1151.            IP   = IP + LENDIR
  1152.            LINE = LINE + 1
  1153. 75      CONTINUE
  1154. C
  1155. 80      WRITE(LUN,90) N
  1156. 90      FORMAT(/' TOTAL OF ',I5,' ARRAYS.')
  1157.       END IF
  1158.       WRITE(LUN,100) MAVAIL, NXTLOC-1, NARY(1)*LENDIR
  1159. 100   FORMAT(/' TOTAL MEMORY IN AMS          ',I6,' WORDS.'/
  1160.      *        ' MEMORY USED BY ARRAYS        ',I6,' WORDS.'/
  1161.      *        ' MEMORY USED BY DIRECTORIES  1',I6,' WORDS.')
  1162.       DO 110 I=2,NDATA
  1163. 110   IF(NOPEN(I).EQ.1) WRITE(LUN,120) I,NARY(I)*LENDIR
  1164. 120   FORMAT( '                            ',I2,I6,' WORDS.')
  1165.       WRITE(LUN,130) IDIR-NXTLOC
  1166. 130   FORMAT(/' MEMORY AVAILABLE IN AMS      ',I6,' WORDS.'/)
  1167.       RETURN
  1168.       END
  1169. C
  1170.       SUBROUTINE DB2TXT( ND, FNAME )
  1171.       IMPLICIT INTEGER*4(I-N)
  1172. C
  1173. C ... LEVEL 1: CONVERT DATABASE ND TO ASCII ARRAY FILE FNAME
  1174. C
  1175.       COMMON    MAVAIL,IA(1)
  1176.       INCLUDE 'AMSCTL.INC'
  1177.       CHARACTER  NAME*4,FNAME*(*)
  1178.       RTN = 'DB2TXT'
  1179.       OPEN(NTF,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED')
  1180.       REWIND NTF
  1181.       N   = NUMDIR()
  1182.       IP  = IDIR
  1183.       DO 30 I=1,N
  1184.          NDX   = IA(IP)
  1185.          IF (NDX.NE.ND) GO TO 15
  1186.          NAME = '    '
  1187.          DO 10 J=1,4
  1188. 10       NAME(J:J) = CHAR(IA(IP+J))
  1189. C
  1190.          CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  1191.          IF (NVMAX.LE.0) GO TO 15
  1192. C
  1193.          WRITE(NTF,100) NAME,NVMAX,NT,NR,NC,MS,NVW
  1194.          IF (NVW.EQ.0) GO TO 15
  1195.          DO 14 J=1,NVW
  1196.             CALL GET(ND,NAME,J,LOC)
  1197.             CALL TALK(NTF,IA(LOC),IA(LOC),IA(LOC),NT,NR,NC,MS)
  1198. 14       CONTINUE
  1199. 15       IP   = IP + LENDIR
  1200. 30    CONTINUE
  1201.       WRITE(NTF,100) '$$$$'
  1202.       CLOSE(NTF)
  1203.       RETURN
  1204. 100   FORMAT(A4,6(1X,I10))
  1205.       END
  1206.  
  1207.       SUBROUTINE TALK(NTF,IARY,RARY,CARY,NT,NR,NC,MS)
  1208.       IMPLICIT INTEGER*4(I-N)
  1209.       IMPLICIT REAL*8(A-H,O-Z)
  1210.       DIMENSION   IARY(1),RARY(1)
  1211.       COMPLEX*16  CARY(1)
  1212.       IF (MS.EQ.0) THEN
  1213.          L = NR*NC
  1214.       ELSE IF (MS.EQ.1) THEN
  1215.          L = (NR+1)*NR/2
  1216.       ELSE
  1217.          L = NR
  1218.       END IF
  1219.       IF (NT.EQ.0) THEN
  1220.          DO 10 I=1,L
  1221. 10       WRITE(NTF,*) IARY(I)
  1222.       ELSE IF (NT.EQ.1) THEN
  1223.          DO 20 I=1,L
  1224. 20       WRITE(NTF,*) RARY(I)
  1225.       ELSE IF (NT.EQ.2) THEN
  1226.          DO 30 I=1,L
  1227. 30       WRITE(NTF,*) CARY(I)
  1228.       ENDIF
  1229.       RETURN
  1230.       END
  1231.  
  1232.       SUBROUTINE TXT2DB( FNAME, ND)
  1233.       IMPLICIT INTEGER*4(I-N)
  1234. C
  1235. C ... LEVEL 1: CONVERT ASCII ARRAY FILE FNAME TO DATABASE ND
  1236. C
  1237.       COMMON    MAVAIL,IA(1)
  1238.       INCLUDE 'AMSCTL.INC'
  1239.       CHARACTER NAME*4,FNAME*(*)
  1240.       RTN = 'TXT2DB'
  1241.       OPEN(NTF,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ERR=200)
  1242.       REWIND NTF
  1243. 10    READ(NTF,100,END=99) NAME,NVMAX,NT,NR,NC,MS,NVW
  1244.       IF (NAME.EQ.'$$$$') GO TO 99
  1245.       CALL DEFINE(ND,NAME,NVMAX,NT,NR,NC,MS,LOC)
  1246.       IF (NVW.EQ.0) GO TO 10
  1247.       DO 20 J=1,NVW
  1248.          CALL HEAR(NTF,IA(LOC),IA(LOC),IA(LOC),NT,NR,NC,MS)
  1249.          CALL SAVE(ND,NAME,J)
  1250. 20    CONTINUE
  1251.       GO TO 10
  1252. 99    CLOSE(NTF)
  1253.       RETURN
  1254. 100   FORMAT(A4,6(1X,I10))
  1255. 200   CALL ERROR(ND,' ',0,21)
  1256.       END
  1257.  
  1258.       SUBROUTINE HEAR(NTF,IARY,RARY,CARY,NT,NR,NC,MS)
  1259.       IMPLICIT INTEGER*4(I-N)
  1260.       IMPLICIT REAL*8(A-H,O-Z)
  1261.       DIMENSION   IARY(1),RARY(1)
  1262.       COMPLEX*16  CARY(1)
  1263.       IF (MS.EQ.0) THEN
  1264.          L = NR*NC
  1265.       ELSE IF (MS.EQ.1) THEN
  1266.          L = (NR+1)*NR/2
  1267.       ELSE
  1268.          L = NR
  1269.       END IF
  1270.       IF (NT.EQ.0) THEN
  1271.          DO 10 I=1,L
  1272. 10       READ(NTF,*) IARY(I)
  1273.       ELSE IF (NT.EQ.1) THEN
  1274.          DO 20 I=1,L
  1275. 20       READ(NTF,*) RARY(I)
  1276.       ELSE IF (NT.EQ.2) THEN
  1277.          DO 30 I=1,L
  1278. 30       READ(NTF,*) CARY(I)
  1279.       ENDIF
  1280.       RETURN
  1281.       END
  1282. C     ********************************************************************
  1283. C     *                                                                  *
  1284. C     *                    AMS - OPERATIONAL MODULE                      *
  1285. C     *                                                                  *
  1286. C     ********************************************************************
  1287.       SUBROUTINE MATINP ( ND, NAME )
  1288.       IMPLICIT INTEGER*4(I-N)
  1289. C ... LEVEL 2: INTERACTIVE MATRIX INPUT ROUTINE  (FOR ND=1 ONLY)
  1290.       COMMON    MAVAIL,IA(1)
  1291.       INCLUDE 'AMSCTL.INC'
  1292.       CHARACTER NAME*(*),DT(0:2)*7,SM(0:2)*9
  1293.       DIMENSION IDT(0:2),ISM(0:2)
  1294.       DATA DT/'Integer','Real','Complex'/,
  1295.      *     SM/'General','Symmetric','Diagonal'/
  1296.       DATA IDT/7,4,7/,ISM/7,9,8/
  1297.       CALL LOCATE(ND,NAME,NT,NR,NC,MS,LOC)
  1298.       RTN = 'MATINP'
  1299.       IF (LOC.EQ.0) THEN
  1300.          CALL ERROR(ND,NAME,0,8)
  1301.       ELSE IF (LOC.LT.0) THEN
  1302.          CALL GET(ND,NAME,1,LOC)
  1303.       END IF
  1304.       WRITE(NTM,10) ND,NAME,NR,NC,DT(NT)(:IDT(NT)),SM(MS)(:ISM(MS))
  1305. 10    FORMAT(1X,'Enter ',I1,1X,A,', (',I5,' by ',I5,') ',A,' ',
  1306.      *       A,' Matrix')
  1307.       DO 30 J=1,NC
  1308.       IF (MS.EQ.0.OR.MS.EQ.1) THEN
  1309.          IS = 1
  1310.       ELSE
  1311.          IS = J
  1312.       ENDIF
  1313.       IF (MS.EQ.1.OR.MS.EQ.2) THEN
  1314.          IE = J
  1315.       ELSE
  1316.          IE = NR
  1317.       ENDIF
  1318.       DO 30 I=IS,IE
  1319.       WRITE(NTM,20) ND,NAME,I,J
  1320. 20    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')='\)
  1321.       CALL INP(NTR,IA(LOC),IA(LOC),IA(LOC),NT)
  1322.       LOC = LOC + NDT(NT)
  1323. 30    CONTINUE
  1324.       RETURN
  1325.       END
  1326. C
  1327.       SUBROUTINE INP(NTR,I,R,C,NT)
  1328.       IMPLICIT INTEGER*4(I-N)
  1329.       IMPLICIT REAL*8(A-H,O-Z)
  1330.       COMPLEX*16 C
  1331.       IF (NT.EQ.0) THEN
  1332.          READ(NTR,*) I
  1333.       ELSE IF (NT.EQ.1) THEN
  1334.          READ(NTR,*) R
  1335.       ELSE IF (NT.EQ.2) THEN
  1336.          READ(NTR,*) C
  1337.       ENDIF
  1338.       RETURN
  1339.       END
  1340. C
  1341.       SUBROUTINE MATOUT ( ND, NAME )
  1342.       IMPLICIT INTEGER*4(I-N)
  1343. C ... LEVEL 2: INTERACTIVE MATRIX OUTPUT ROUTINE (FOR ND=1 ONLY)
  1344.       COMMON    MAVAIL,IA(1)
  1345.       INCLUDE 'AMSCTL.INC'
  1346.       CHARACTER NAME*(*),DT(0:2)*7,SM(0:2)*9
  1347.       DIMENSION IDT(0:2),ISM(0:2)
  1348.       DATA DT/'Integer','Real','Complex'/
  1349.      *     SM/'General','Symmetric','Diagonal'/
  1350.       DATA IDT/7,4,7/,ISM/7,9,8/
  1351.       CALL LOCATE(ND,NAME,NT,NR,NC,MS,LOC)
  1352.       RTN = 'MATOUT'
  1353.       IF (LOC.LE.0) THEN
  1354.          WRITE(NTM,10) ND,NAME
  1355. 10       FORMAT(' MATOUT: ARRAY NOT INCORE OR NOT EXISTS - ',I1,1X,A)
  1356.          RETURN
  1357.       ENDIF
  1358.       WRITE(NTM,20) ND,NAME,NR,NC,DT(NT)(:IDT(NT)),SM(MS)(:ISM(MS))
  1359. 20    FORMAT(1X,'Output of ',I1,1X,A,', (',I5,' by ',I5,') ',
  1360.      *       A,' ',A,' Matrix')
  1361.       DO 30 J=1,NC
  1362.       IF (MS.EQ.0.OR.MS.EQ.1) THEN
  1363.          IS = 1
  1364.       ELSE
  1365.          IS = J
  1366.       ENDIF
  1367.       IF (MS.EQ.1.OR.MS.EQ.2) THEN
  1368.          IE = J
  1369.       ELSE
  1370.          IE = NR
  1371.       ENDIF
  1372.       DO 30 I=IS,IE
  1373.       CALL OUT(NTM,ND,NAME,I,J,IA(LOC),IA(LOC),IA(LOC),NT)
  1374.       LOC = LOC + NDT(NT)
  1375. 30    CONTINUE
  1376.       RETURN
  1377.       END
  1378. C
  1379.       SUBROUTINE OUT(NTM,ND,NAME,IR,IC,I,R,C,NT)
  1380.       IMPLICIT INTEGER*4(I-N)
  1381.       IMPLICIT REAL*8(A-H,O-Z)
  1382.       COMPLEX*16 C
  1383.       CHARACTER  NAME*(*)
  1384.       IF (NT.EQ.0) THEN
  1385.          WRITE(NTM,10)  ND,NAME,IR,IC, I
  1386.       ELSE IF (NT.EQ.1) THEN
  1387.          WRITE(NTM,20)  ND,NAME,IR,IC, R
  1388.       ELSE IF (NT.EQ.2) THEN
  1389.          WRITE(NTM,30)  ND,NAME,IR,IC, C
  1390.       ENDIF
  1391.       RETURN
  1392. 10    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',I8)
  1393. 20    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',1PE14.5)
  1394. 30    FORMAT(1X,I1,1X,A,'(',I5,',',I5,')=',1PE14.5,'+',1PE14.5,'I')
  1395.       END
  1396. C
  1397. C ... AMS EXTENSION SUBROUTINES
  1398. C
  1399.       CHARACTER*2 FUNCTION NUMSTR( KI )
  1400.       CHARACTER*2 S
  1401.       IF (KI.LT.0.OR.KI.GT.99) STOP 'NUMSTR ERROR'
  1402.       WRITE(S,'(I2.2)') KI
  1403.       NUMSTR = S
  1404.       RETURN
  1405.       END
  1406. C
  1407.       FUNCTION INSPCT( ND, NAME, ATTR )
  1408.       IMPLICIT REAL*8 (A-H,O-Z)
  1409.       IMPLICIT INTEGER*4(I-N)
  1410. C ... LEVEL 1:  INSPECT ONE OF THE MATRIX ATTRIBUTES 
  1411.       CHARACTER*(*) NAME,ATTR
  1412.       INCLUDE 'AMSCTL.INC'
  1413.       RTN = 'INSPCT'
  1414.       INSPCT = 0
  1415.       IF (ND.LE.0.OR.ND.GT.NDATA) CALL ERROR(ND,NAME,0,16)
  1416.       IF (NOPEN(ND).EQ.0)         CALL ERROR(ND,NAME,0,15)
  1417.       IP  = LOOK(ND,NAME)
  1418.       IF (IP.GT.0) THEN
  1419.          CALL XFER(IP,NT,NR,NC,MS,NVMAX,NVW,IREC,IOFF,LOC,NSIZE,NDROP)
  1420.          IF (ATTR.EQ.'NT') THEN
  1421.             INSPCT = NT
  1422.          ELSE IF (ATTR.EQ.'NR') THEN
  1423.             INSPCT = NR
  1424.          ELSE IF (ATTR.EQ.'NC') THEN
  1425.             INSPCT = NC
  1426.          ELSE IF (ATTR.EQ.'MS') THEN
  1427.             INSPCT = MS
  1428.          ELSE IF (ATTR.EQ.'NVMAX') THEN
  1429.             INSPCT = NVMAX
  1430.          ELSE IF (ATTR.EQ.'NVW') THEN
  1431.             INSPCT = NVW
  1432.          ELSE IF (ATTR.EQ.'IREC') THEN
  1433.             INSPCT = IREC
  1434.          ELSE IF (ATTR.EQ.'IOFF') THEN
  1435.             INSPCT = IOFF
  1436.          ELSE IF (ATTR.EQ.'LOC') THEN
  1437.             INSPCT = LOC
  1438.          ELSE IF (ATTR.EQ.'NSIZE') THEN
  1439.             INSPCT = NSIZE
  1440.          ELSE IF (ATTR.EQ.'NDROP') THEN
  1441.             INSPCT = NDROP
  1442.          ELSE 
  1443.             INSPCT = 0
  1444.          END IF
  1445.       ELSE
  1446.          STOP 'INSPCT'
  1447.       END IF
  1448.       RETURN
  1449.       END
  1450.  
  1451.